#!/usr/bin/perl
#
# A program to analyze the linkage between mail address and place
# Uses the USER mail address, and the placeid from the personrec
#
use FileTable;
use POSIX;

# Controlling constants.
$maxdata = 5000; # How many entries to read
$p_compat = 0.9; # Percentage that must be "consistent" with the
                   # indicated place: This or a superior.
$p_exact = 0.5; # Percentage that must be AT the indicated place
$dom_moveup = 1; # If this many people in a domain, delete a subdom
                 # and move its data up (or toss it, if toplevel)
$dom_report = 5; # Min number of emails in a domain to report

# Debug. 1 = report domain data.
$debug = 0;

while ($ARGV[0] =~ /^-/) {
    $opt = shift;
    if ($opt eq "-n") {
	$maxdata = shift(@ARGV) + 0;
	print STDERR "Maxdata is $maxdata\n";
    } elsif ($opt eq "-d") {
	++ $debug;
	print STDERR "Debug level is $debug\n";
    }
}

$users = FileTable::open("db/users");
$persons = FileTable::open("db/persons");

while ($key = $users->each()) {
    ++ $entries;
    $user = $users->get($key);
    $person = $persons->getclean($key);
    if (!$user || !$person) {
	++ $notentry;
	next;
    } elsif (!$person->{placeid} || !$user->{email}) {
	++ $notdata;
	next;
    }
    ($domain = $user->{email}) =~ s/^.*\@//; # all @-signs removed
    $placeid = $person->{placeid};
    ++ $xref{"\L$domain"}{"\L$placeid"};
    ++ $items{"\L$domain"};
    ++ $data;
    print STDERR "$data/$notentry/$notdata\r" if $data % 10 == 0 && -t STDERR ;
    last if $entries >= $maxdata;
}
print STDERR "Data: $data\n";
print STDERR "Not both entries: $notentry\n";
print STDERR "Not all data: $notdata\n";
# Tabulate
for $dom (sort {$items{$b} <=> $items{$a}} keys(%xref)) {
    # Only do doms with "significant" data
    last if $items{$dom} < $dom_report;
    ($rec, $why) = findplace($xref{$dom}, $items{$dom});
    if ($debug >= 1) {
	print "Domain $dom ($items{$dom}):\n";
	print "-- Recommend $rec with comment $why\n";
	if ($debug >= 2) {
	    for $place (sort {$xref{$dom}{$b} <=> $xref{$dom}{$a}}
			keys(%{$xref{$dom}})) {
		print "   $xref{$dom}{$place} $place\n";
	    }
	}
    }
    if ($rec ne "NONE" && $dom !~ /\.$rec/) {
	print "$rec: $dom # $why\n";
    } elsif ($rec ne "NONE" && $debug) {
	print "Boring: $rec: $dom # why\n";
    }

}

sub findplace {
    my ($arg, $count) = @_;
    @places = sort {$$arg{$b} <=> $$arg{$a}} keys(%{$arg});
    $candidate = $places[0];
    while ($candidate =~ /:/
	   && exactbelow($candidate, $arg) < $count * $p_exact
	   && compatible($candidate, $arg) < $count * $p_compat)  {
	if ($debug >= 2) {
	    printf("Reject candidate $candidate - score E %4.1f%% C %4.1f%%\n",
		   exactbelow($candidate, $arg) * 100 / $count,
		   compatible($candidate, $arg) * 100 / $count);
	}
	$candidate =~ s/:+[^:]+$//;
	++ $skipcount;
	# Try one level up
    }
    $compatible = compatible($candidate, $arg);
    $exact = exactbelow($candidate, $arg);
    $why = $candidate;
    $why .= " Exact/Within "
	    . sprintf("%4.1f%%", $exact * 100 / $count);
    $why .= " Compat "
	    . sprintf("%4.1f%%", $compatible * 100 / $count);
    if ($compatible / $count > $p_compat) {
	$recommend = $candidate;
    } else {
	$recommend = "NONE";
    }
    return ($recommend, $why);
}

sub exactbelow {
# Count places where candidate is identical or a prefix of name
    my ($cand, $arr) = @_;
    my ($compatible, $place);
    for $place (keys(%$arr)) {
	if ($place =~ /^$cand/) {
	    $compatible += $$arr{$place};
	}
    }
    $compatible;
}

sub compatible {
# Places that match, or are less specific but compatible
    my ($cand, $arr) = @_;
    my ($compatible, $place);
    for $place (keys(%$arr)) {
	if ($place =~ /^$cand/ || $cand =~ /^$place/ || $place eq "xw") {
	    $compatible += $$arr{$place};
	}
    }
    $compatible;
}
		   
